home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch3 / GetEntry.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-04-01  |  4.7 KB  |  146 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
  3. Begin VB.Form frmGetEntry 
  4.    Caption         =   "GetEntry"
  5.    ClientHeight    =   3495
  6.    ClientLeft      =   1500
  7.    ClientTop       =   1260
  8.    ClientWidth     =   5910
  9.    LinkTopic       =   "Form1"
  10.    PaletteMode     =   1  'UseZOrder
  11.    ScaleHeight     =   3495
  12.    ScaleWidth      =   5910
  13.    Begin MSComDlg.CommonDialog dlgOpenFile 
  14.       Left            =   3240
  15.       Top             =   480
  16.       _ExtentX        =   847
  17.       _ExtentY        =   847
  18.       _Version        =   393216
  19.       CancelError     =   -1  'True
  20.    End
  21.    Begin VB.TextBox txtColors 
  22.       BeginProperty Font 
  23.          Name            =   "Courier New"
  24.          Size            =   8.25
  25.          Charset         =   0
  26.          Weight          =   400
  27.          Underline       =   0   'False
  28.          Italic          =   0   'False
  29.          Strikethrough   =   0   'False
  30.       EndProperty
  31.       Height          =   3495
  32.       Left            =   3480
  33.       MultiLine       =   -1  'True
  34.       ScrollBars      =   2  'Vertical
  35.       TabIndex        =   1
  36.       Top             =   0
  37.       Width           =   2415
  38.    End
  39.    Begin VB.PictureBox picCanvas 
  40.       AutoRedraw      =   -1  'True
  41.       Height          =   3495
  42.       Left            =   0
  43.       ScaleHeight     =   229
  44.       ScaleMode       =   3  'Pixel
  45.       ScaleWidth      =   221
  46.       TabIndex        =   0
  47.       Top             =   0
  48.       Width           =   3375
  49.    End
  50.    Begin VB.Menu mnuFile 
  51.       Caption         =   "&File"
  52.       Begin VB.Menu mnuFileOpen 
  53.          Caption         =   "&Open..."
  54.          Shortcut        =   ^O
  55.       End
  56.    End
  57. Attribute VB_Name = "frmGetEntry"
  58. Attribute VB_GlobalNameSpace = False
  59. Attribute VB_Creatable = False
  60. Attribute VB_PredeclaredId = True
  61. Attribute VB_Exposed = False
  62. Option Explicit
  63. Private Type PALETTEENTRY
  64.     peRed As Byte
  65.     peGreen As Byte
  66.     peBlue As Byte
  67.     peFlags As Byte
  68. End Type
  69. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  70. Private Declare Function GetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  71. Private Const RASTERCAPS = 38    ' Raster device capabilities.
  72. Private Const RC_PALETTE = &H100 ' Has palettes.
  73. ' Display a list of the colors in the logical palette.
  74. Private Sub ShowEntries()
  75. Dim num_entries As Integer
  76. Dim palentry(0 To 255) As PALETTEENTRY
  77. Dim i As Integer
  78. Dim txt As String
  79.     If picCanvas.Picture = 0 Then
  80.         txtColors.Text = "No picture loaded."
  81.         Exit Sub
  82.     ElseIf picCanvas.Picture.hPal = 0 Then
  83.         txtColors.Text = "Default palette."
  84.         Exit Sub
  85.     End If
  86.     num_entries = GetPaletteEntries(picCanvas.Picture.hPal, 0, 256, palentry(0))
  87.     txt = "  #  Red Green Blue" & vbCrLf
  88.     For i = 0 To num_entries - 1
  89.         txt = txt & _
  90.             Format$(i, "@@@") & ":" & _
  91.             Format$(palentry(i).peRed, "@@@@") & _
  92.             Format$(palentry(i).peGreen, "@@@@@@") & _
  93.             Format$(palentry(i).peBlue, "@@@@@") & _
  94.             vbCrLf
  95.     Next i
  96.     txtColors.Text = txt
  97. End Sub
  98. Private Sub Form_Load()
  99.     ' Make sure the screen supports palettes.
  100.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  101.         Beep
  102.         MsgBox "This monitor does not support palettes.", _
  103.             vbCritical
  104.         End
  105.     End If
  106.     ' Start in the current directory.
  107.     dlgOpenFile.InitDir = App.Path
  108.     ShowEntries
  109. End Sub
  110. Private Sub Form_Resize()
  111. Dim wid As Single
  112.     txtColors.Move ScaleWidth - txtColors.Width, _
  113.         0, txtColors.Width, ScaleHeight
  114.     wid = txtColors.Left - 20
  115.     If wid < 100 Then wid = 100
  116.     picCanvas.Move 0, 0, wid, ScaleHeight
  117. End Sub
  118. ' Load a picture.
  119. Private Sub mnuFileOpen_Click()
  120. Dim fname As String
  121.     ' Allow the user to pick a file.
  122.     On Error Resume Next
  123.     dlgOpenFile.FileName = "*.BMP;*.WMF;*.DIB;*.JPG;*.GIF"
  124.     dlgOpenFile.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  125.     dlgOpenFile.ShowOpen
  126.     If Err.Number = cdlCancel Then
  127.         Exit Sub
  128.     ElseIf Err.Number <> 0 Then
  129.         Beep
  130.         MsgBox "Error selecting file.", , vbExclamation
  131.         Exit Sub
  132.     End If
  133.     On Error GoTo 0
  134.     MousePointer = vbHourglass
  135.     DoEvents
  136.     fname = Trim$(dlgOpenFile.FileName)
  137.     dlgOpenFile.InitDir = Left$(fname, Len(fname) _
  138.         - Len(dlgOpenFile.FileTitle) - 1)
  139.     ' Load the picture.
  140.     picCanvas.Picture = LoadPicture(fname)
  141.     Caption = "GetEntry [" & fname & "]"
  142.     ' Update the list of colors.
  143.     ShowEntries
  144.     MousePointer = vbDefault
  145. End Sub
  146.